;;; -*- Mode: LISP; Package: USER; Base: 10 -*-

(HERALD GENFACT)

(DEFUN GENERATE-ADD-FACT-PART (ALIST)
  (LET (!SINGLE-PROPS! !ADDITIVE-PROPS! !ADDITIVE-VARS! !SINGLE-VARS!)
    (SETQ !SINGLE-PROPS! (LOOP FOR X IN ALIST WHEN (AND (EQ (CADR X)
							    (QUOTE SINGLE))
							(EQ (CADDR X)
							    (QUOTE PROPERTY)))
			       COLLECT (CAR X)))
    (SETQ !ADDITIVE-PROPS!
	  (LOOP FOR X IN ALIST WHEN (AND (EQ (CADR X)
					     (QUOTE ADDITIVE))
					 (EQ (CADDR X)
					     (QUOTE PROPERTY)))
		COLLECT (CAR X)))
    (SETQ !ADDITIVE-VARS!
	  (LOOP FOR X IN ALIST WHEN (AND (EQ (CADR X)
					     (QUOTE ADDITIVE))
					 (EQ (CADDR X)
					     (QUOTE VARIABLE)))
		COLLECT (CAR X)))
    (SETQ !SINGLE-VARS!
	  (LOOP FOR X IN ALIST WHEN (AND (EQ (CADR X)
					     (QUOTE SINGLE))
					 (EQ (CADDR X)
					     (QUOTE VARIABLE)))
		COLLECT (CAR X)))
    `(PROGN (COND
	      ((NULL VAL)
	       (ERROR1 (PQUOTE (PROGN |Attempt| |to| |do| |an| ADD-FACT
				      |with| |value| (!PPR NIL NIL)
				      |on|
				      (!PPR PROP NIL) |and| (!PPR ATM NIL)
				      /.))
		       (BINDINGS (QUOTE PROP)
				 PROP
				 (QUOTE ATM)
				 ATM)
		       (QUOTE HARD))))
	    (SELECTQ PROP
	      (,!SINGLE-PROPS!
	       (COND
		 ((GET1 ATM PROP)
		  (ERROR1 (PQUOTE (PROGN |Attempt| |to| |smash|
					 |existing| SINGLE
					 PROPERTY |fact| |hung|
					 |under| (!PPR PROP NIL)
					 |of|
					 (!PPR ATM NIL)
					 /.))
			  (BINDINGS (QUOTE PROP)
				    PROP
				    (QUOTE ATM)
				    ATM)
			  (QUOTE HARD))))
	       (PUT1 ATM VAL PROP))
	      (,!ADDITIVE-PROPS! (PUT1 ATM (CONS VAL (GET1 ATM PROP))
				       PROP))
	      (DCELL (COND
		       ((OUR-FBOUNDP ATM)
			(ERROR1 (PQUOTE (PROGN |Attempt| |to|
					       |smash|
					       |existing|
					       LISP
					       |definition|
					       |cell| |of| |the|
					       |function|
					       (!PPR ATM NIL)
					       /.))
				(BINDINGS (QUOTE ATM)
					  ATM)
				(QUOTE HARD)))
		       (T (PUTD1 ATM VAL))))
	      (,!ADDITIVE-VARS!
	       (OR (NULL ATM)
		   (ERROR1 (PQUOTE (PROGN ADD-SUB-FACT |must|
					  |not| |be| |called| |with|
					  PROP |set| |to| |a|
					  |variable| |name|
					  |while| ATM |is|
					  |non-NIL| |because| |it|
					  |confuses| |the| |undo|
					  |information| /.))
			   NIL
			   (QUOTE HARD)))
	       (SET PROP (CONS VAL (SYMEVAL PROP))))
	      (,!SINGLE-VARS!
	       (OR (NULL ATM)
		   (ERROR1 (PQUOTE (PROGN ADD-SUB-FACT |must|
					  |not| |be| |called| |with|
					  PROP |set| |to| |a|
					  |variable| |name|
					  |while| ATM |is|
					  |non-NIL| |because| |it|
					  |confuses| |the| |undo|
					  |information| /.))
			   NIL
			   (QUOTE HARD)))
	       (COND
		 ((BOUNDP PROP)
		  (ERROR1 (PQUOTE (PROGN |Attempt| |to| |smash|
					 |existing| SINGLE
					 VARIABLE /,
					 (!PPR PROP NIL)
					 /.))
			  (BINDINGS (QUOTE PROP)
				    PROP)
			  (QUOTE HARD))))
	       (SET PROP VAL))
	      (OTHERWISE
	       (ERROR1 (PQUOTE (PROGN ADD-SUB-FACT |has| |been|
				      |called| |on| |a| |property|
				      |or| |variable| |name| /,
				      |namely| (!PPR PROP NIL)
				      /, |that| |was| |not|
				      |declared|
				      !))
		       (BINDINGS (QUOTE PROP)
				 PROP)
		       (QUOTE HARD)))))))

(DEFUN GENERATE-ADD-SUB-FACT1 (ALIST)
  (COND
    ((AND (LOOP FOR X IN (QUOTE (IDATE SATELLITES MAIN-EVENT EVENT
				       LOCAL-UNDO-TUPLES))
		ALWAYS (AND (SETQ TEMP-TEMP (ASSQ X ALIST))
			    (MATCH (CDR TEMP-TEMP)
				   (LIST (QUOTE HIDDEN)
					 (QUOTE PROPERTY)))))
	  (MATCH (ASSQ (QUOTE CHRONOLOGY) ALIST)
		 (LIST (QUOTE CHRONOLOGY) (QUOTE HIDDEN) (QUOTE VARIABLE)))
	  (LOOP FOR X IN ALIST
		NEVER (AND (EQ (CADR X) (QUOTE HIDDEN))
			   (NOT (MEMQ (CAR X)
				      (QUOTE (IDATE SATELLITES
						    MAIN-EVENT EVENT
						    LOCAL-UNDO-TUPLES
						    CHRONOLOGY)))))))
     (SUB-PAIR
       (QUOTE (!LIB-PROPS! !LIBVARS! !SUBTRACT-FACT! !UNDO-TUPLE!
			   !ADD-FACT!))
       (LIST (NREVERSE (LOOP FOR X IN ALIST
			     WHEN (EQ (CADDR X)
				      (QUOTE PROPERTY))
			     COLLECT (CAR X)))
	     (LOOP FOR X IN ALIST WHEN (EQ (CADDR X)
					   (QUOTE VARIABLE))
		   COLLECT (CAR X))
	     (GENERATE-SUB-FACT-PART ALIST)
	     (GENERATE-UNDO-TUPLE-PART ALIST)
	     (GENERATE-ADD-FACT-PART ALIST))
       (QUOTE
	 (COND
	   (INIT
	    (INIT-LIB (QUOTE !LIB-PROPS!) (QUOTE !LIBVARS!)))
	   (TUPLE !SUBTRACT-FACT!)
	   (T
	    (COND
	      ((OR
		 (EQ MAIN-EVENT-NAME (QUOTE GROUND-ZERO))
		 (AND
		   (OR (EQ MAIN-EVENT-NAME ATM)
		       (AND ATM
			    (EQ MAIN-EVENT-NAME
				(GET1 ATM
				      (QUOTE MAIN-EVENT)))))
		   (NEQ PROP (QUOTE DCELL))))
	       NIL)
	      (T (PUT1 MAIN-EVENT-NAME
		       (CONS !UNDO-TUPLE!
			     (GET1 MAIN-EVENT-NAME
				   (QUOTE LOCAL-UNDO-TUPLES)))
		       (QUOTE LOCAL-UNDO-TUPLES))))
	    !ADD-FACT!)))))
    (T (AN-ERROR (LIST (QUOTE |
The user must declare all the built-in event level properties and variables as
HIDDEN and must not declare any other HIDDEN data.|))))))

(DEFUN GENERATE-SUB-FACT-PART (ALIST)
  (SUBST
    (CONS (QUOTE SELECTQ)
	  (CONS (QUOTE PROP)
		(NCONC1 (LOOP FOR X IN ALIST WHEN (EQ (CADR X)
						      (QUOTE ADDITIVE))
			      COLLECT (LIST (CAR X)
					    (CADDDR X)))
			(QUOTE (OTHERWISE NIL)))))
    (QUOTE !VAL-NAME!)
    (QUOTE (LET (ATM PROP VAL-NAME VAL TEMP)
	     (COND
	       ((ATOM TUPLE)
		(SETQ PROP TUPLE)
		(SET PROP NIL))
	       ((ATOM (CDR TUPLE))
		(SETQ PROP (CAR TUPLE))
		(SETQ ATM (CDR TUPLE))
		(COND
		  ((EQ PROP (QUOTE DCELL))
		   (PUTD1 ATM NIL))
		  (T (PUTPROP ATM NIL PROP))))
	       (T (SETQ PROP (CAR TUPLE))
		  (SETQ ATM (CADR TUPLE))
		  (SETQ VAL-NAME (CDDR TUPLE))

;   In the following (and in the LET above) TEMP was introduced to skirt a
;   bug in the Release 5.0 compiler.
		  
		  (SETQ TEMP (LOOP FOR VAL IN (COND
					       ((NULL ATM)
						(SYMEVAL PROP))
					       (T (GET1 ATM PROP)))
				  WHEN (EQUAL !VAL-NAME! VAL-NAME)
				  DO (RETURN VAL)))
		  (COND
		    ((NULL TEMP)
		     (ERROR1 (PQUOTE (PROGN |In| |undoing| |an|
					    ADDITIVE ADD-FACT
					    |on| (!PPR ATM NIL)
					    |and| (!PPR PROP NIL)
					    |the| |value| |to|
					    |be| |removed| |was| |not|
					    |found| /.))
			     (BINDINGS (QUOTE PROP)
				       PROP
				       (QUOTE ATM)
				       ATM)
			     (QUOTE WARNING))))
		  (COND
		    ((NULL ATM)
		     (SET PROP (REMOVE1 TEMP (SYMEVAL PROP))))
		    (T (PUTPROP ATM (REMOVE1 TEMP
					     (GET1 ATM PROP)) PROP)))))
	     NIL))))

(DEFUN GENERATE-UNDO-TUPLE-PART (ALIST)
  (LET (!ADDITIVE! !---ADDITIVE-LST---! !SINGLE-VARS!)
    (SETQ !ADDITIVE! (QUOTE (!ADDITIVE-TYPE! (CONS PROP
						   (CONS ATM
							 !VAL-NAME!)))))
    (SETQ !---ADDITIVE-LST---!
	  (LOOP FOR X IN ALIST WHEN (EQ (CADR X)
					(QUOTE ADDITIVE))
		COLLECT (SUB-PAIR (QUOTE (!ADDITIVE-TYPE! !VAL-NAME!))
				 (LIST (CAR X)
				       (CADDDR X))
				 !ADDITIVE!)))
    (SETQ !SINGLE-VARS! (LOOP FOR X IN ALIST
			      WHEN (AND (EQ (CADR X)
					    (QUOTE SINGLE))
					(EQ (CADDR X)
					    (QUOTE VARIABLE)))
			      COLLECT (CAR X)))
    `(SELECTQ PROP ,@!---ADDITIVE-LST---!
	      (,!SINGLE-VARS! PROP)
	      (DCELL (CONS (QUOTE DCELL) ATM))
	      (OTHERWISE (CONS PROP ATM)))))